home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-closure.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  6.6 KB  |  184 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ------------------------------------------------- ;
  2. ; File:         zebu-closure.lisp
  3. ; Description:  Conversion to CL of the original Scheme program by (W M Wells)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      31-Oct-90
  6. ; Modified:     Tue Aug  2 16:11:09 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;;             Copyright (C) 1989, by William M. Wells III
  18. ;;;                         All Rights Reserved
  19. ;;;     Permission is granted for unrestricted non-commercial use.
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. (in-package "ZEBU")
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;               Calculate the closure of an lr(0) set of items
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26.  
  27. (defun closure (I)
  28.   (declare (type oset I))
  29.   (let ((eset 
  30.      (make-oset :order-fn #'item-order-function)
  31.       ))
  32.     ;; I is an oset of items.
  33.     ;; This is non-destructive.
  34.     ;; See Fig. 4.33 of Dragon
  35.     (labels ((closure-insert-item! (item)
  36.            ;; Add an item to an oset of items. Add his pals too if he wasn't
  37.            ;; there already.
  38.            (when (oset-insert! item eset)
  39.          (unless (dot-at-right-end? item)
  40.            (dolist (production 
  41.                  (the list 
  42.                   (g-symbol-own-productions
  43.                    (symbol-after-dot item)))
  44.                 nil)
  45.              (let ((new (new-item production)))
  46.                (closure-insert-item! new)))
  47.            ))))
  48.       (dolist (x (oset-item-list I)) (closure-insert-item! x))
  49.       eset)))
  50.  
  51. #||
  52. (defun closure (I)
  53.   (declare (type oset I))
  54.   (let ((eset (make-oset :order-fn #'item-order-function)))
  55.     ;; I is an oset of items.
  56.     ;; This is non-destructive.
  57.     ;; See Fig. 4.33 of Dragon
  58.     (labels ((closure-insert-item! (item)
  59.            ;; Add an item to an oset of items. Add his pals too if he wasn't
  60.            ;; there already.
  61.            (when (oset-insert! item eset)
  62.          (unless (dot-at-right-end? item)
  63.            (dolist (production (g-symbol-own-productions
  64.                     (symbol-after-dot item)))
  65.              (closure-insert-item! 
  66.               (the item (new-item production))))))))
  67.       (dolist (x (oset-item-list I)) (closure-insert-item! x))
  68.       eset)))
  69. ||#
  70.  
  71. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72. ;;;
  73. ;;; Calculate the lr(1) closure of a set of lr(1) items.
  74. ;;; Currently, find the closure of a set of one lr(1) item.
  75. ;;;
  76. ;;; An lr(1) item data structure with a set of lookaheads
  77. ;;; actually stands for a set of lr(1) items which are the
  78. ;;; same except for each having one lookahead from the set.
  79.  
  80. (defun single-item-closure-1 (lr0-item look-ahead)
  81.   (let ((eset (make-oset :order-fn #'item-order-function)))
  82.     (closure-1-insert-item! lr0-item look-ahead eset)
  83.     eset))
  84.  
  85.  
  86. ;;; Destructively take the lr(1) closure of an item set
  87. ;;; (actually an oset of items... not an item-set structure).
  88. ;;; Empty out the set and re-insert the contents with closures.
  89.  
  90. (defun closure-1! (item-set)
  91.   (let ((item-list (oset-item-list item-set)))
  92.     (setf (oset-item-list item-set) nil)
  93.     (dolist (item item-list)
  94.       (let ((the-look-aheads (item-look-aheads item)))
  95.     (setf (item-look-aheads item) 
  96.           (make-oset :order-fn #'g-symbol-order-function))
  97.     (dolist (look-ahead (oset-item-list the-look-aheads))
  98.       (closure-1-insert-item! item look-ahead item-set))))))
  99.  
  100. ;----------------------------------------------------------------------------;
  101. ; closure-1-insert-item!
  102. ;-----------------------
  103. ; See Dragon Fig. 4.38
  104. ; 
  105.  
  106. (defun closure-1-insert-item! (lr0-item look-ahead item-set)
  107.   (declare (type item lr0-item))
  108.   (labels ((closure-1-insert-item-aux (lr0-item look-ahead)
  109.          (multiple-value-bind (item-not-there-already the-item)
  110.          (oset-insert-2! lr0-item item-set)
  111.            (when (or (oset-insert! look-ahead (item-look-aheads the-item))
  112.              item-not-there-already)
  113.          ;; Item wasn't already there with that lookahead
  114.          ;; so insert his buddies too.
  115.          (unless (dot-at-right-end? lr0-item)
  116.            (let* ((prod (item-production lr0-item))
  117.               (rhs  (rhs prod))
  118.               (after-dot-rhs
  119.                (nthcdr (the fixnum (item-after-dot lr0-item))
  120.                    (the cons rhs)))
  121.               (gs-list (oset-item-list
  122.                     (first-seq-1
  123.                       ;; This gets the list corresponding to the
  124.                       ;; part of the item beyond the symbol after
  125.                       ;; the dot.
  126.                       (cdr (the cons after-dot-rhs))
  127.                       look-ahead))))
  128.              (dolist (prod (g-symbol-own-productions
  129.                     (car (the cons after-dot-rhs))))
  130.                (dolist (gs gs-list)
  131.              (let ((new (new-item prod)))
  132.                (closure-1-insert-item-aux new gs))))))))))
  133.     (closure-1-insert-item-aux lr0-item look-ahead)))
  134.  
  135. #|
  136. (defun closure-1-insert-item! (lr0-item look-ahead item-set)
  137.   (declare (type item lr0-item))
  138.   (labels ((closure-1-insert-item-aux (lr0-item look-ahead)
  139.          (multiple-value-bind (item-not-there-already the-item)
  140.          (oset-insert-2! lr0-item item-set)
  141.            (when (or (oset-insert! look-ahead (item-look-aheads the-item))
  142.              item-not-there-already)
  143.          ;; Item wasn't already there with that lookahead
  144.          ;; so insert his buddies too.
  145.          (unless (dot-at-right-end? lr0-item)
  146.            (let* ((prod (item-production lr0-item))
  147.               (rhs  (rhs prod))
  148.               (after-dot-rhs
  149.                (nthcdr (the fixnum (item-after-dot lr0-item))
  150.                    (the cons rhs)))
  151.               (gs-list (oset-item-list
  152.                     (first-seq-1
  153.                       ;; This gets the list corresponding to the
  154.                       ;; part of the item beyond the symbol after
  155.                       ;; the dot.
  156.                       (cdr (the cons after-dot-rhs))
  157.                       look-ahead))))
  158.              (dolist (prod (g-symbol-own-productions
  159.                     (car (the cons after-dot-rhs))))
  160.                (dolist (gs gs-list)
  161.              (closure-1-insert-item-aux
  162.               (new-item prod) gs)))))))))
  163.     (closure-1-insert-item-aux lr0-item look-ahead)))
  164. |#
  165.  
  166. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  167. ;;; test:
  168. #||
  169. (set-working-directory *ZEBU-test-directory*)
  170. (zb::load-grammar "ex1.zb")
  171. (zb::compile-slr-grammar "ex1.zb")
  172. (zebu-load-file "ex1.tab")
  173. (calculate-empty-string-derivers)
  174. (calculate-first-sets)
  175. (setq f-item (new-item (car (reverse *productions*))))
  176. (setq f-i-set (single-item-closure-1
  177.            f-item *the-end-g-symbol*))
  178. (item-list-print (oset-item-list f-i-set))
  179. ||#
  180.  
  181. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  182. ;;                              End of closure1.l
  183. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  184.